Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/cwtpu.zip/CWARE.PAS

Pascal/Delphi Source File | 1993-01-04 | 15KB | 463 lines

{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}

Unit CWare;

(* Version 1.0 - CollisionWare Premium SoftWare - Compiled by Kito Mann *)
(* This unit is a simple collection of some some procedures aquired     *)
(* from other programs and myself. New versions will have added         *)
(* procedures, and the present ones will be improved. Comments, bugs,   *)
(* and questions accepted.                                              *)
(* Keep in mind that there is NO WARANTY! It IS NOT GAURANTEED that all *)
(* these procedures will work!                                          *)
(* If you modify the procedures included, or add your own, I request    *)
(* that you send me a copy of the new unit and source code.             *)

(* It'd probably be helpful if you declare ErrorCode: byte in your main *)
(* program. It is used as an Error variable much like the DosError used *)
(* in the DOS unit.                                                     *)

(* The Collision Theory pm-BBS *)
(*         10PM-7AM            *)
(*      [phone]          *)
(*         Burke, VA           *)
(* "Dedicated to Intelligent   *)
(*        Conversation"        *)

INTERFACE

Uses Crt,
     Dos;

const
  MaxDirEnteries=       20;    { Maximum number of directories that can be specified to search }
                               { This doesn't include those searched "below" ones specified.   }

type
  FullNameStr=          string[12];                 { Type for storing name+dot+extention                                 }
  DirSearchEntry=       record                      { This data type is used to store all the paths that will be searched }
                          Dir:         DirStr;      {   <-- Path to search                                                }
                          Name:        FullNameStr; {   <-- File spec to search                                           }
                          Below:       boolean;     {   <-- TRUE=search directories below the specified one               }
                        end;
  ProcType=             procedure(var S: SearchRec; P: PathStr);
  AnyStr=               string[255];


var
  EngineMask:           FullNameStr;
  EngineAttr:           byte;
  EngineProc:           ProcType;
  EngineCode:           byte;

  Reg:                  Registers;   { Register storage for DOS calls }
  OldSeg,OldOfs:        word;
  BufData:              longint;
  BufferSeg:            word;
  BufferOfs:            word;
  BufferLen:            word;
  BufferPtr:            pointer;
  T:                    text;
  P:                    PathStr;

(* The following procedures are from A2Z by Ian Mclean *)

function FileFound(F: ComStr): boolean;

function DateString: string;

function TimeString: string;

procedure SearchEngine(Mask: PathStr; Attr: byte; Proc: ProcType; var ErrorCode: byte);

function GoodDirectory(S: SearchRec): boolean;

procedure SearchOneDir(var S: SearchRec; P: PathStr);

procedure SearchEngineAll(Path: PathStr; Mask: FullNameStr; Attr: byte;
                          Proc: ProcType; var ErrorCode: byte);

procedure IPP;

procedure NewExitProc2;

procedure ResetBuffer;

function BufSize: word;

function InBuffer(S: string): integer;

procedure InstallInterruptHandler;

procedure DeleteFiles(P: string);

procedure DeleteDir(P:string);

procedure Tab(s1,s2:AnyStr; i:integer);

function Strr(i:LongInt): AnyStr;

function UpCaseString(st:AnyStr): AnyStr;

procedure ListFiles(P: string; complete:boolean; pausenum:integer);

IMPLEMENTATION

function FileFound(F: ComStr): boolean;
{
  This returns TRUE if the file F exists, FALSE otherwise.  F can contain
  wildcard characters.
}
var
  SRec:                 SearchRec;
begin
  SRec.Name := '*';
  FindFirst(F,0,SRec);
  if SRec.Name='*' then FileFound := false else FileFound := true;
end;


  function DateString: string;
  {
    Returns the current date in a string of the form:  MON ## YEAR.
    E.g, 21 Feb 1989 or 02 Jan 1988.
  }
  const
    Month:              array[1..12] of string[3]=
                        ('Jan','Feb','Mar','Apr','May','Jun',
                         'Jul','Aug','Sep','Oct','Nov','Dec');
  var
    Y,M,D,Junk:         word;
    DS,YS:              string[5];
  begin
    GetDate(Y,M,D,Junk);
    Str(Y,YS);
    Str(D,DS);
    if length(DS)<2 then DS := '0'+DS;
    DateString := DS+' '+Month[M]+' '+YS;
  end;

  function TimeString: string;
  {
    Returns the current time in the form:  HH:MM am/pm
    E.g, 12:00 am or 09:12 pm.
  }
  var
    H,M,Junk:           word;
    HS,MS:              string[5];
    Am:                 boolean;
  begin
    GetTime(H,M,Junk,Junk);
    case H of
      0:     begin
               Am := true;
               H := 12;
             end;
      1..11: Am := true;
      12:    Am := false;
      else   begin
               Am := false;
               H := H-12;
             end;
    end;
    Str(H,HS);
    Str(M,MS);
    if length(HS)<2 then HS := '0'+HS;
    if length(MS)<2 then MS := '0'+MS;
    if Am then TimeString := HS+':'+MS+' am'
    else TimeString := HS+':'+MS+' pm';
  end;

(********* The following search engine routines are sneakly swiped *********)
(********* from Turbo Technix v1n6.  See there for further details *********)

procedure SearchEngine(Mask: PathStr; Attr: byte; Proc: ProcType;
                       var ErrorCode: byte);
var
  S:                    SearchRec;
  P:                    PathStr;
  Ext:                  ExtStr;
begin
  FSplit(Mask, P, Mask, Ext);
  Mask := Mask+Ext;
  FindFirst(P+Mask,Attr,S);
  if DosError<>0 then
  begin
    ErrorCode := DosError;
    exit;
  end;
  while DosError=0 do
  begin
    Proc(S, P);
    FindNext(S);
  end;
  if DosError=18 then ErrorCode := 0
  else ErrorCode := DosError;
end;

function GoodDirectory(S: SearchRec): boolean;
begin
  GoodDirectory := (S.name<>'.') and (S.Name<>'..') and
  (S.Attr and Directory=Directory);
end;

procedure SearchOneDir(var S: SearchRec; P: PathStr);
begin
  if GoodDirectory(S) then
  begin
    P := P+S.Name;
    SearchEngine(P+'\'+EngineMask,EngineAttr,EngineProc,EngineCode);
    SearchEngine(P+'\*.*',Directory or Archive, SearchOneDir,EngineCode);
  end;
end;

procedure SearchEngineAll(Path: PathStr; Mask: FullNameStr; Attr: byte;
                          Proc: ProcType; var ErrorCode: byte);
begin
  EngineMask := Mask;
  EngineProc := Proc;
  EngineAttr := Attr;
  SearchEngine(Path+Mask,Attr,Proc,ErrorCode);
  SearchEngine(Path+'*.*',Directory or Archive,SearchOneDir,ErrorCode);
  ErrorCode := EngineCode;
end;

(************** Thus ends the sneakly swiped code *************)

procedure IPP;
{ Interrupt pre-processor.  This is a new handler for interrupt 29h which
  provides special functions.  See comments in IHAND.ASM}
begin
  InLine(
      $06/                   {          push    es                      }
      $1E/                   {          push    ds                      }
      $53/                   {          push    bx                      }
      $57/                   {          push    di                      }
      $BB/$3F/$3F/           {          mov     bx, 3f3fh               }
      $8E/$C3/               {          mov     es, bx                  }
      $BB/$3F/$3F/           {          mov     bx, 3f3fh               }
      $26/$8B/$3F/           {          mov     di, word ptr [es:bx]    }
      $26/$8E/$5F/$02/       {          mov     ds, word ptr [es:bx+2]  }
      $88/$05/               {          mov     byte ptr [di], al       }
      $26/$FF/$07/           {          inc     word ptr [es:bx]        }
      $5F/                   {          pop     di                      }
      $5B/                   {          pop     bx                      }
      $1F/                   {          pop     ds                      }
      $07/                   {          pop     es                      }
      $3C/$0A/               {          cmp     al, 10                  }
      $75/$28/               {          jne     looper                  }
      $50/                   {          push    ax                      }
      $52/                   {          push    dx                      }
      $51/                   {          push    cx                      }
      $53/                   {          push    bx                      }
      $B4/$03/               {          mov     ah, 3                   }
      $B7/$00/               {          mov     bh, 0                   }
      $CD/$10/               {          int     10h                     }
      $80/$FE/$18/           {          cmp     dh, 24                  }
      $75/$15/               {          jne     popper                  }
      $FE/$CE/               {          dec     dh                      }
      $B7/$00/               {          mov     bh, 0                   }
      $B4/$02/               {          mov     ah, 2                   }
      $CD/$10/               {          int     10h                     }
      $B8/$01/$06/           {          mov     ax, 0601h               }
      $B7/$07/               {          mov     bh, 7                   }
      $B9/$00/$11/           {          mov     cx, 1100h               }
      $BA/$4F/$18/           {          mov     dx, 184fh               }
      $CD/$10/               {          int     10h                     }
      $5B/                   {  popper: pop     bx                      }
      $59/                   {          pop     cx                      }
      $5A/                   {          pop     dx                      }
      $58/                   {          pop     ax                      }
      $9C/                   {  looper: pushf                           }
      $9A/$00/$00/$00/$00/   {          call    far [0:0]               }
      $CF);                  {          iret                            }
end;


procedure NewExitProc2;
{ This exit procedure removes the interrupt 29h handler from memory and places
  the cursor at the bottom of the screen. }
begin
  Reg.AH := $25;
  Reg.AL := $29;
  Reg.DS := OldSeg;
  Reg.DX := OldOfs;
  MsDos(Reg);
  Window(1,1,80,25);
  GotoXY(1,24);
  TextAttr := $07;
  ClrEol;
end;

procedure ResetBuffer;
{ Reset pointers to the text buffer, effectivly deleting any text in it }
begin
  MemW[seg(BufData):ofs(BufData)] := BufferOfs;    { Set first 2 bytes of BufData to point to buffer offset }
  MemW[seg(BufData):ofs(BufData)+2] := BufferSeg;  { And next two bytes to point to buffer segment }
  MemW[seg(IPP):ofs(IPP)+21] := seg(BufData);    { Now point the interrupt routine to BufData for pointer }
  MemW[seg(IPP):ofs(IPP)+26] := ofs(BufData);    {  to the text buffer }
end;

function BufSize: word;
{ This returns the number of characters in the text buffer.  It's what BufData
  now points to minus what is origionally pointed to, eg, the number of times
  IPP incremented it }
begin
  BufSize := MemW[seg(BufData):ofs(BufData)]-BufferOfs;
end;

function InBuffer(S: string): integer;
{ This searched the text buffer for the string S, and if it's found returns
  the offset in the buffer.  If it's not found a -1 is returned }
var
  L,M:                  word;
  X:                    byte;
begin
  X := 1;
  L := BufferOfs;
  M := BufSize;
  while (X<=length(S)) and (L<=M) do
  begin
    if Mem[BufferSeg:L]=byte(S[X]) then Inc(X) else X := 1;
    Inc(L);
  end;
  if X>length(S) then InBuffer := L-length(S) else InBuffer := -1;
end;

procedure InstallInterruptHandler;
{ Installs the int 29h handler }
begin
  BufferLen := $4000;  { Set up a 16k buffer }
  GetMem(BufferPtr,BufferLen);  { Allocate memory pointed at by BufferPtr }
  BufferSeg := seg(BufferPtr^);  { Read segment and offset of buffer for easy access }
  BufferOfs := ofs(BufferPtr^);
  ResetBuffer;    { Place these values in the IPP routine, resetting buffer }
  Reg.AH := $35;
  Reg.AL := $29;  { DOS service 35h, get interrupt vector for 29h }
  MsDos(Reg);
  OldSeg := Reg.ES;   { Store the segment and offset of the old vector for later use }
  OldOfs := Reg.BX;
  MemW[seg(IPP):ofs(IPP)+90] := Reg.BX;  { And store them so IPP can call the routine }
  MemW[seg(IPP):ofs(IPP)+92] := Reg.ES;
  Reg.AL := $29; { DOS service 25h, set interrupt vector 29h }
  Reg.AH := $25;
  Reg.DS := seg(IPP);    { Store segment and offset for IPP.  The +16 is to skip TP stack }
  Reg.DX := ofs(IPP)+16; { maintainence routines }
  MsDos(Reg);
end;

{ Next two procedures slightly modifed }

  procedure DeleteFiles(P: string);
  {
    Delete all files in the directory named, including
    Hidden, Read-only, System and other file types.
  }
  var
    SRec:               SearchRec;
    ErrorCode:          byte;
  begin
    FindFirst(P+'\*.*',0,SRec);
    while DosError=0 do
    begin
      Assign(T, P+'\'+SRec.Name);
      SetFAttr(T,Archive);
      writeln('Deleting ',P,+'\'+Srec.Name);
      {$I-}
      Erase(T);
      {$I+}
      ErrorCode := IOResult;
      FindNext(SRec);
    end;
    ErrorCode := IOResult;
end;

procedure DeleteDir(P:string);

{ Simply deletes specified directory }

var ErrorCode: byte;
begin
  DeleteFiles(P);
  {$I-}
  RmDir(P);
  {$I+}
  ErrorCode := IOResult;
end;

(* The following procedures NOT from A2Z, but from Kito D. Mann *)

procedure Tab(s1,s2:AnyStr; i:integer);

{ Writes s1, then goes to i-length(s1) and writes s2 }

var j,k:integer;
begin
  j:=length(s1);
  i:=i-j;
  write(s1);
  for k:=1 to i do write(' ');
  write(s2);
end;

function Strr(i:longint): AnyStr;

{ Converts an integer to string }

var outcome:AnyStr;
begin
  str(i,outcome);
  Strr:=outcome;
end;

function UpCaseString(st:AnyStr): AnyStr;

{ Converts a string to all upcase chars }

var i:integer; {st2:AnyStr;}
begin
   for i:=1 to length(st) do st[i]:=UpCase(st[i]);
   UpCaseString:=st;
end;

procedure ListFiles(P: string; complete:boolean; pausenum:integer);
  {
   If complete is true then will show the name and file size of every
   file. Otherwise will just show the filename. Numlines is the number
   of files it will display before a pause. 0 means no pause.
  }
  var
    SRec:               SearchRec;
    ErrorCode:          byte;
    Size:               AnyStr;
    Index:              integer;
    TheChar:            char;
    Quit:               boolean;

  begin
    Quit:=false;
    FindFirst(P+'\*.*',0,SRec);
    Index:=1;
    while DosError=0 do
    begin
       if Index=pausenum then
       begin
        write('[Q=quit, ANY KEY=continue]:');
        TheChar:=ReadKey;
        if UpCase(TheChar)='Q' then quit:=true;
        writeln;
        Index:=0;
       end;
      if NOT Quit then
      if complete then begin
        Size:=strr(Srec.Size);
        tab(Srec.Name,Size,15);
        writeln;
      end else
      writeln(Srec.Name);
      FindNext(SRec);
      Inc(Index);
    end;
    ErrorCode := IOResult;
end;

end.